perm filename RUNFNS[NET,KMC] blob
sn#165202 filedate 1975-06-24 generic text, type T, neo UTF8
(SETQ &IDTYPE 0)
(SETQ &STRTYPE 1)
(SETQ &NUMTYPE 2)
(SETQ &DELIMTYPE 3)
(SETQ &X& (SETQ &Y& NIL))
(MAPCAR (FUNCTION
(LAMBDA (&X)
(PROG2 (PUTPROP (CAR &X) &IDTYPE (QUOTE &TRANSTYPE))
(PUTPROP (CAR &X) (CADR &X) (QUOTE &TRANS)))))
(QUOTE ((/* TIMES) (// QUOTIENT) (/+ PLUS) (/- DIFFERENCE)
(/↑ PRELIST) (/↓ SUFLIST) (/@ APPEND)
(/= EQUAL) (/≠ NEQUAL) (/≤ LEQUAL) (/≥ GEQUAL) (/ε MEMBER)
(/& AND) (/∧ AND) (/| OR) (/∨ OR) (/¬ NOT))))
(MAPCAR (FUNCTION
(LAMBDA (&X)
(PROG NIL
(MAPCAR (FUNCTION
(LAMBDA (&Y)
(PROG NIL
(AND (EQ (CAR &X) (QUOTE &PREFIX))
(PUTPROP &Y 1000. (QUOTE &RIGHT))
(PUTPROP &Y -1 (QUOTE &LEFT)))
(AND (EQ (CAR &X) (QUOTE &RESWORD))
(PUTPROP &Y -1. (QUOTE &LEFT)))
(AND (EQ (CAR &X) (QUOTE &DELIM))
(PUTPROP &Y -1. (QUOTE &LEFT)))
(PUTPROP &Y T (CAR &X)))))
(CDR &X)))))
(QUOTE ((&RESWORD BEGIN END NEW SPECIAL IF THEN ELSE ALSO
FOR IN ON TO BY DO COLLECT UNTIL WHILE
EXPR FEXPR LEXPR MACRO LAMBDA DEFINE COMMENT INLINE OCTAL)
(&DELIM /( /) /< /> /[ /] /; /, /. /' /⊗)
(&FNTYPE EXPR FEXPR LEXPR MACRO)
(&ASSOC TIMES PLUS AND OR)
(&SPECIAL QT LPAR RPAR LABR RABR LSBR RSBR DASH STAR PLUSS SLASH
BLANK COLON COMMA PERIOD DOLLAR EQSIGN LARROW DBQUOTE PERCENT
CIRCLEX UNDERBAR SEMICOLON TAB LF VT FF CR ALTMODE TRUE FALSE F)
(&PREFIX STR STRP STRLEN AT PRINTSTR DIFFERENCE
CAR CDR
CAAR CADR CDAR CDDR
CAAAR CAADR CADAR CDAAR CADDR CDADR CDDAR CDDDR
CAAAAR CAAADR CAADAR CADAAR CDAAAR CAADDR CADADR CDAADR
CADDAR CDADAR CDDAAR CADDDR CDADDR CDDADR CDDDAR CDDDDR
ABS ADD1 ARG ASCII ATOM BAKGAG CSYM DDTIN DDTOUT ED ERR EVAL *EVAL
EXAMINE EXPLODE EXPLODEC FIX FLATSIZE FUNCTION *FUNCTION GCGAG
*GETSYM GO INITFN INTERN LAST LENGTH LINELENGTH MAKNAM MINUS
MINUSP NCONS NOT NOUUO NULL NUMBERP NUMVAL PLUS PRINC PRINT PRIN1
QUOTE READLIST RETURN REVERSE *RSET SUB1 TERPRI TYO ZEROP))))
(MAPCAR (FUNCTION
(LAMBDA (&X)
(MAPCAR (FUNCTION
(LAMBDA (&Y)
(PROG2 (PUTPROP &Y (CADDR &X) (QUOTE &RIGHT))
(PUTPROP &Y (CADR &X) (QUOTE &LEFT)))))
(CAR &X))))
(QUOTE (((/← SETQ STORE) 1001. 0.)
((TIMES *TIMES QUOTIENT *QUO) 700. 750.)
((PLUS *PLUS DIFFERENCE *DIF) 600. 650.)
((&DEFAULT) 500. 550.)
((APPEND *APPEND NCONC CONS XCONS CAT) 450. 400.)
((EQ NEQ EQUAL NEQUAL LESSP *LESS LEQUAL GREATERP *GREAT GEQUAL
MEMBER MEMQ) 300. 350.)
((AND) 200. 250.)
((OR) 100. 150.))))
(DEFPROP INIT1
(LAMBDA NIL
(PROG NIL
(SETQ SCNVAL NIL)
(*PUTSYM (QUOTE SCNVAL) (GET (QUOTE SCNVAL) (QUOTE VALUE)))
(LOAD T)))
EXPR)
(DEFPROP INIT2
(LAMBDA NIL
(PROG NIL
(GETSYM SUBR SCAN SCANINIT SCANSET SCANRESET LETTER IGNORE UNTYI SREAD)
(SCANINIT 45 45 42 42 77) ~ % % (COMMENT) " " (STRING) ? (LITERAL)
(LETTER 30) ~ _ (UNDERBAR)
(LETTER 72) ~ : (COLON)
(LETTER 41) ~ ! (EXCLAMATION POINT)
(IGNORE 11) ~ TAB
(IGNORE 12) ~ LINE FEED
(IGNORE 13) ~ VERTICAL TAB
(IGNORE 14) ~ FORM FEED
(IGNORE 15) ~ CARRIAGE RETURN
(IGNORE 40) ~ BLANK
(IGNORE 175) ~ ALTMODE
(SETQ BASE (SETQ IBASE 10.)) ~ ALL I/O IS IN DECIMAL TO START WITH
(REMPROP (QUOTE LAP) (QUOTE MACRO))
(REMOB RUNFN1 RUNFN2 MINIT SETQS MACROS MACRO1 COMPLR INIT1 INIT2)
(INITFN (QUOTE MEVAL))))
EXPR)
(SETQ QT (QUOTE /' ))
(SETQ LPAR (QUOTE /( ))
(SETQ RPAR (QUOTE /) ))
(SETQ LABR (QUOTE /< ))
(SETQ RABR (QUOTE /> ))
(SETQ LSBR (QUOTE /[ ))
(SETQ RSBR (QUOTE /] ))
(SETQ DASH (QUOTE /- ))
(SETQ STAR (QUOTE /* ))
(SETQ PLUSS (QUOTE /+ ))
(SETQ SLASH (QUOTE // ))
(SETQ BLANK (QUOTE / ))
(SETQ COLON (QUOTE /: ))
(SETQ COMMA (QUOTE /, ))
(SETQ PERIOD (QUOTE /. ))
(SETQ DOLLAR (QUOTE /$ ))
(SETQ EQSIGN (QUOTE /= ))
(SETQ LARROW (QUOTE /← ))
(SETQ DBQUOTE (QUOTE /" ))
(SETQ PERCENT (QUOTE /% ))
(SETQ CIRCLEX (QUOTE /⊗ ))
(SETQ UNDERBAR (QUOTE /_ ))
(SETQ SEMICOLON (QUOTE /; ))
(SETQ TAB (INTERN (ASCII 11)))
(SETQ LF (INTERN (ASCII 12)))
(SETQ VT (INTERN (ASCII 13)))
(SETQ FF (INTERN (ASCII 14)))
(SETQ CR (INTERN (ASCII 15)))
(SETQ ALTMODE (INTERN (ASCII 175)))
(SETQ TRUE T)
(SETQ FALSE (SETQ F NIL))
(SETQ BASE (SETQ IBASE 10.))
(PROG (&UNBOUND&))
(SETQ *NOPOINT T)
(NOUUO NIL)
(DEFPROP &X&
T
SPECIAL)
(DEFPROP &Y&
T
SPECIAL)
(DEFPROP &FOR
(LAMBDA (X) (&FOR1 (CADADR X) (CAR (CDADDR X)) (CADR (CADDDR X)) (CADAR (CDDDDR X)) (&LISTLST (CADADR X) 1)))
MACRO)
(DEFPROP &DO
(LAMBDA (X) (&LOOP1 (CAR X) (CADADR X) (CAR (CDADDR X)) (CADR (CADDDR X))))
MACRO)
(DEFPROP &WHILE
(LAMBDA (X) (&LOOP1 (CAR X) (CADADR X) (CADR (CADDDR X)) (CAR (CDADDR X))))
MACRO)
(DEFPROP &INDEX
(LAMBDA (X) (&CARS (CADR X) (CDADDR X) 4))
MACRO)
(DEFPROP &FOR
(LAMBDA (L FN EX B)
(PROG (&Y& NOTFIRST LST)
(SETQ LST
(MAPCAR (FUNCTION
(LAMBDA (&X&)
(CONS (LIST (CADR &X&)
(EQ (CADDR &X&) (QUOTE ON))
(EQ (CADDR &X&) (QUOTE ←))
(EQ (CAR &X&) (QUOTE NEW))
(COND ((GET (CADR &X&) (QUOTE VALUE)) (CDR (GET (CADR &X&) (QUOTE VALUE))))
(T (CDR (GET (QUOTE &UNBOUND&) (QUOTE VALUE))))))
(EVAL (CADDDR &X&)))))
L))
LOOP (COND ((&FORSTOP LST) (&FORRESET LST T) (RETURN &Y&)))
(MAPCAR (FUNCTION (LAMBDA (&X&) (SET (CAAR &X&) (COND ((CADAR &X&) (CDR &X&)) (T (CADR &X&)))))) LST)
(SETQ &Y& (EVAL (COND (NOTFIRST (LIST FN (QUOTE &Y&) EX)) (T (SETQ NOTFIRST T) EX))))
(COND ((EVAL B) (&FORRESET LST NIL) (RETURN &Y&)))
(SETQ LST
(MAPCAR (FUNCTION
(LAMBDA (&X&) (CONS (CAR &X&) (COND ((CADDAR &X&) (EVAL (CDDR &X&))) (T (CDDR &X&))))))
LST))
(GO LOOP)))
EXPR)
(DEFPROP &FORSTOP
(LAMBDA (L) (AND L (OR (NULL (CDAR L)) (&FORSTOP (CDR L)))))
EXPR)
(DEFPROP &FORRESET
(LAMBDA (L &Y&)
(MAPCAR (FUNCTION
(LAMBDA (&X&)
(COND ((CADDDR (CAR &X&)) (SET (CAAR &X&) (CADDDR (CDAR &X&))))
(T (AND &Y& (NULL (CDR &X&)) (SET (CAAR &X&) NIL))))))
L))
EXPR)
(DEFPROP &RANGE
(LAMBDA (LOW UP INC) (COND ((EQUAL INC 0) NIL) (T (&RANGE1 LOW UP INC (*GREAT INC 0) (*LESS INC 0)))))
EXPR)
(DEFPROP &RANGE1
(LAMBDA (LOW UP INC POS NEG)
(COND ((OR (AND POS (*GREAT LOW UP)) (AND NEG (*LESS LOW UP))) NIL)
(T (LIST LOW (QUOTE &RANGE1) (*PLUS LOW INC) UP INC POS NEG))))
EXPR)
(DEFPROP &DO
(LAMBDA (FN EX B) (PROG (V) L (SETQ V (FN V (EVAL EX))) (COND ((EVAL B) (RETURN V)) (T (GO L)))))
EXPR)
(DEFPROP &WHILE
(LAMBDA (FN B EX) (PROG (V) L (COND ((EVAL B) (SETQ V (FN V (EVAL EX)))) (T (RETURN V))) (GO L)))
EXPR)
(DEFPROP &INDEX
(LAMBDA (L X) (COND (X (CAR (SUFLIST (CAR (SUFLIST L (SUB1 (CAR X)))) (SUB1 X)))) (T L)))
EXPR)
(LAP © SUBR)
(PUSH P 6)
(MOVEI 6 4)
(PUSH P (C 0))
(MOVE 3 ISPTR_)
(MOVEM 3 SPTR_)
(MOVE 3 IDPTR_)
(MOVEM 3 DPTR_)
(HLRZ@ 4 1)
(HLRZ@ 5 2)
(133000 0 SPTR_)
LOOP_
(134000 3 SPTR_)
(CAIN 3 42)
(JRST 0 FINISH_)
(136000 3 DPTR_)
(367000 6 LOOP_)
(MOVEI 6 4)
(MOVEM 2 0 P)
(MOVE 3 ISPTR_)
(MOVEM 3 SPTR_)
(HRRZ@ 1 1)
(HLRZ@ 4 1)
(134000 3 SPTR_)
(CAIN 3 42)
(JRST 0 LASTCH_)
(136000 3 DPTR_)
(MOVE 3 IDPTR_)
(MOVEM 3 DPTR_)
(HRRZ@ 2 2)
(HLRZ@ 5 2)
(JRST 0 LOOP_)
LASTCH_
(MOVEI 1 0)
(136000 1 DPTR_)
FINISH_
(MOVEI 1 0)
(CAIN 6 4)
(JRST 0 NULLCDR_)
LOOP1_
(136000 1 DPTR_)
(365000 6 LOOP1_)
EXIT_
(POP P 2)
(POP P 6)
(POPJ P)
NULLCDR_
(336000 0 0 P)
(334000 1 (C 0 0 (QUOTE T) 0))
(HRRM@ 1 0 P)
(JRST 0 EXIT_)
ISPTR_
(440700 0 0 4)
IDPTR_
(440700 0 0 5)
SPTR_
(0)
DPTR_
(0)
NIL
(LAP &STRP SUBR)
(HLRZ@ 3 1)
(MOVE 4 PTR_)
(134000 5 4)
(CAIE 5 42)
(JRST 0 FALSE_)
(MOVEI 5 5)
(CAMN 1 2)
(364000 5 LOOP_)
(HLRZ@ 3 2)
(MOVE 4 PTR_)
LOOP_
(134000 1 4)
(JUMPE 1 FALSE_)
(CAIN 1 42)
(JRST 0 TRUE_)
(367000 5 LOOP_)
FALSE_
(TDZA 1 1)
TRUE_
(MOVEI 1 (QUOTE T))
(POPJ P)
PTR_
(440700 0 0 3)
NIL
(DEFPROP &X&
T
SPECIAL)
(DEFPROP &Y&
T
SPECIAL)
(DEFPROP NEQ
(LAMBDA (X) (LIST (QUOTE NOT) (CONS (QUOTE EQ) (CDR X))))
MACRO)
(DEFPROP NEQUAL
(LAMBDA (X) (LIST (QUOTE NOT) (CONS (QUOTE EQUAL) (CDR X))))
MACRO)
(DEFPROP LEQUAL
(LAMBDA (X) (LIST (QUOTE NOT) (CONS (QUOTE GREATERP) (CDR X))))
MACRO)
(DEFPROP GEQUAL
(LAMBDA (X) (LIST (QUOTE NOT) (CONS (QUOTE LESSP) (CDR X))))
MACRO)
(DEFPROP PRELIST
(LAMBDA (L N)
(PROG (&V &VV &L1 &L2 &UPPER1 &X& I)
(SETQ &L1 1)
(SETQ &UPPER1 N)
(SETQ &L2 L)
(SETQ &V (SETQ &VV (LIST NIL)))
LOOP (COND ((OR (*GREAT &L1 &UPPER1) (NULL &L2)) (RETURN (CDR &V))))
(SETQ &X& &L1)
(SETQ I (CAR &L2))
(SETQ &L1 (ADD1 &L1))
(SETQ &L2 (CDR &L2))
(NCONC &VV (SETQ &VV (LIST I)))
(GO LOOP)))
EXPR)
(DEFPROP SUFLIST
(LAMBDA (L N)
(COND ((*LESS N 1) L)
(T (PROG (&V)
LOOP (COND ((AND L (NOT (*LESS (SETQ N (SUB1 N)) 0))) (SETQ &V (SETQ L (CDR L)))) (T (RETURN &V)))
(GO LOOP)))))
EXPR)
(DEFPROP STR
(LAMBDA (X)
(PROG2 (COND ((SETQ X (EXPLODEC X)) (RPLACD (LAST X) (QUOTE (/")))) (T (SETQ X (QUOTE (/")))))
(READLIST (CONS (QUOTE /") X))))
EXPR)
(DEFPROP STRP
(LAMBDA (X) (AND (ATOM X) (NOT (NUMBERP X)) (&STRP (GET X (QUOTE PNAME)) (LAST (GET X (QUOTE PNAME))))))
EXPR)
(DEFPROP STRLEN
(LAMBDA (X) (LENGTH (EXPLODEC X)))
EXPR)
(DEFPROP SEQ
(LAMBDA (X Y) (EQUAL (EXPLODEC X) (EXPLODEC Y)))
EXPR)
(DEFPROP AT
(LAMBDA (X)
(COND ((NOT (ATOM X)) (AT (STR X)))
((NUMBERP X) (READLIST (CONS (QUOTE //) (EXPLODE X))))
((NOT (STRP X)) X)
(T (PROG (S D G)
(SETQ G (GENSYM))
(SETQ S (GET X (QUOTE PNAME)))
(PUTPROP G
(SETQ D (MAPCAR (FUNCTION (LAMBDA (X) (CAR (GET (GENSYM) (QUOTE PNAME))))) S))
(QUOTE PNAME))
(RETURN (COND ((© S D) (QUOTE &NONAME)) (T (INTERN G))))))))
EXPR)
(DEFPROP CAT
(LAMBDA (X Y) (READLIST (CONS (QUOTE /") (APPEND (EXPLODEC X) (APPEND (EXPLODEC Y) (LIST (QUOTE /")))))))
EXPR)
(DEFPROP SUBSTR
(LAMBDA (S STRT LEN)
(READLIST
(CONS (QUOTE /")
(APPEND (COND ((NUMBERP LEN) (PRELIST (SUFLIST (EXPLODEC S) (SUB1 STRT)) LEN))
(T (SUFLIST (EXPLODEC S) (SUB1 STRT))))
(LIST (QUOTE /"))))))
EXPR)
(DEFPROP PRINTSTR
(LAMBDA (X) (TERPRI (PRINC X)))
EXPR)
(DEFPROP PRINTTY
(LAMBDA (X) (PROG (FILE) (SETQ FILE (OUTC NIL NIL)) (PRINC X) (PRINC (QUOTE " ")) (OUTC FILE NIL) (RETURN X)))
EXPR)
(DEFPROP NEQ
(LAMBDA (X Y) (NOT (EQ X Y)))
EXPR)
(DEFPROP NEQUAL
(LAMBDA (X Y) (NOT (EQUAL X Y)))
EXPR)
(DEFPROP LEQUAL
(LAMBDA (X Y) (NOT (*GREAT X Y)))
EXPR)
(DEFPROP GEQUAL
(LAMBDA (X Y) (NOT (*LESS X Y)))
EXPR)
(DEFPROP &VECTOR
(LAMBDA (PREFIX FN X Y)
(COND (PREFIX
(COND ((AND X (ATOM X))
(COND ((GET FN (QUOTE MACRO)) (EVAL (LIST FN (LIST (QUOTE QUOTE) X)))) (T (FN X))))
(T (MAPCAR FN X))))
(T (PROG (V L ATOMX ATOMY CARX CARY M)
(SETQ ATOMX (AND X (ATOM X)))
(SETQ ATOMY (AND Y (ATOM Y)))
(SETQ M (GET FN (QUOTE MACRO)))
(COND
((AND ATOMX ATOMY)
(RETURN
(COND (M (EVAL (LIST FN (LIST (QUOTE QUOTE) X) (LIST (QUOTE QUOTE) Y)))) (T (FN X Y))))))
(SETQ V (SETQ L (LIST NIL)))
LOOP (COND ((OR (NULL X) (NULL Y)) (RETURN (CDR V))))
(COND (ATOMX (SETQ CARX X)) (T (SETQ CARX (CAR X)) (SETQ X (CDR X))))
(COND (ATOMY (SETQ CARY Y)) (T (SETQ CARY (CAR Y)) (SETQ Y (CDR Y))))
(SETQ L
(CDR
(RPLACD L
(LIST
(COND (M (EVAL (LIST FN (LIST (QUOTE QUOTE) CARX) (LIST (QUOTE QUOTE) CARY))))
(T (FN CARX CARY)))))))
(GO LOOP)))))
EXPR)
(DEFPROP &REPLACE
(LAMBDA (L X V) (COND (X (&REP1 L X V (CAR X) 1)) (T V)))
EXPR)
(DEFPROP &REP1
(LAMBDA (L X V Y N)
(COND ((ATOM L)
(COND ((EQUAL Y N) (CONS (&REPLACE NIL (CDR X) V) NIL)) (T (CONS NIL (&REP1 NIL X V Y (ADD1 N))))))
((EQUAL Y N) (CONS (&REPLACE (CAR L) (CDR X) V) (CDR L)))
(T (CONS (CAR L) (&REP1 (CDR L) X V Y (ADD1 N))))))
EXPR)
(DEFPROP &DECOMPOSE
(LAMBDA (TEM L) (PROG2 (&DEC1 TEM L NIL) L))
EXPR)
(DEFPROP &DEC1
(LAMBDA (TEM L U)
(COND ((NULL TEM) (NULL L))
((ATOM TEM) (OR (EQ TEM (QUOTE _)) (SET TEM L) T))
((ATOM L) (OR (AND (NULL L) (EQUAL TEM (QUOTE (_)))) (&SETNIL TEM)))
((EQ (CAR TEM) (QUOTE _)) (OR (&DEC1 (CDR TEM) L T) (&DEC1 TEM (CDR L) U)))
(U (AND (&DEC1 (CAR TEM) (CAR L) T) (&DEC1 (CDR TEM) (CDR L) T)))
(T (SETQ U (&DEC1 (CAR TEM) (CAR L) NIL)) (AND (&DEC1 (CDR TEM) (CDR L) NIL) U))))
EXPR)
(DEFPROP &SETNIL
(LAMBDA (TEM)
(COND ((OR (NULL TEM) (EQ TEM (QUOTE _))) NIL)
((ATOM TEM) (SET TEM NIL))
(T (&SETNIL (CAR TEM)) (&SETNIL (CDR TEM)))))
EXPR)